Oh!X 2001 Spring/Oh!X 2001 Spring Special CD-ROM (Japan) (Track 1).bin/TCLTK/BLOCKUP/blockup.tcl

Text File | 2000-05-07 | 16.2 KB | 696 lines

#
# BLOCKUP.tcl : ゲーム「ブロックアップ」
#
#               Copyright (C) 2000 by Makoto Hiroi
#
# 駒を下から押し上げて、同じ色を３つ以上ならべて消すゲーム
# 色は、赤、青、黄、緑、紫、水色、オレンジ
#
# 大域変数
# board()      : 積みあがった駒の色
# board_l()    : ブロックの移動ライン
# color()      : 色
# block()      : ブロックの色
# next_block() : 次のブロック
# block_x      : ブロックの先頭 x 座標
# remove_piece : 消去できる駒の座標（リスト）
# down_piece   : 駒が落ちた場所の座標（リスト）
# move_count   : ブロックを移動させるカウンタ
# play_flag    : 0 : ゲーム終了, 1 : ゲーム中
# piece_num    : 駒の種類（ゲーム中で使用する）
# clolr_num    : メニューで設定する
# name,data,score : トップ１０用スコア
#

# ヘルプファイルの表示
proc help {} {
    global path_name
    if {![winfo exist .t0]} {
        toplevel .t0
        wm title .t0 "BlockUp Help"
        text .t0.text -yscrollcommand ".t0.scroll set"
        scrollbar .t0.scroll -command ".t0.text yview"
    pack .t0.scroll -side right -fill y
    pack .t0.text -side left
    # ファイルの読み込み
        set f [open "$path_name/BLOCKUP.TXT" r]
    while {![eof $f]} {
        .t0.text insert end [read $f 1000]
    }
    close $f
    .t0.text configure -state disabled
    }
}

# スコアファイルリード
proc read_score_file {} {
    global score_file name date score
    set now_date [clock seconds]
    if [file exists $score_file] {
    # ファイルの読み込み
    set f [open $score_file r]
    foreach j {6 7 8} {
        for {set i 1} {$i <= 10} {incr i} {
        if {[gets $f line] < 0} {
            # ダミーデータをセット
            set l " \t$now_data\t0"
        }
        set l [split $line "\t"]
        set name($j,$i)  [lindex $l 0]
        set date($j,$i)  [lindex $l 1]
        set score($j,$i) [lindex $l 2]
        }
    }
    close $f
    } else {
    # ダミーデータのセット
    foreach j {6 7 8} {
        for {set i 1} {$i <= 10} {incr i} {
        set name($j,$i) ""
        set date($j,$i) $now_date
        set score($j,$i) 0
        }
    }
    }
}

# スコアファイルライト
proc write_score_file {} {
    global score_file name date score
    set f [open $score_file w]
    foreach j {6 7 8} {
    for {set i 1} {$i <= 10} {incr i} {
        puts $f [format "%s\t%d\t%d" $name($j,$i) $date($j,$i) $score($j,$i)]
    }
    }
    close $f
}

#
# トップテンウィンドウを開く
#
proc open_score_window {ranking} {
    global name date score piece_num color_num play_flag
    if [winfo exists .t1] {
    destroy .t1
    }
    toplevel .t1
    wm title .t1 "Top 10"
    frame .t1.f0
    frame .t1.f1
    label .t1.f0.l0 -text "順位  名前" -anchor w
    label .t1.f1.l0 -text " 記録   日付  " -anchor w
    pack .t1.f0.l0 -fill x
    pack .t1.f1.l0 -fill x
    if {$play_flag == 0} {
    set num $color_num
    } else {
    set num $piece_num
    }
    for {set i 1} {$i <= 10} {incr i} {
    label .t1.f0.l$i -text [format "%4d %-20s" $i $name($num,$i)] -anchor w
    label .t1.f1.l$i -text [format "%6d %8s" \
                $score($num,$i) \
                [clock format $date($num,$i) -format "%y/%m/%d"]]
    pack  .t1.f0.l$i -fill x
    pack  .t1.f1.l$i -fill x
    }
    if {$ranking > 0} {
    .t1.f0.l$ranking configure -fg red
    .t1.f1.l$ranking configure -fg red
    }
    pack .t1.f0 .t1.f1 -side left
}

# ベストテンに入るか
proc check_hi_score {now_score} {
    global score piece_num
    for {set i 1} {$i <= 10} {incr i} {
    if {$score($piece_num,$i) < $now_score} {
        # ベストテンに入ったよ
        return $i
    }
    }
    return 0
}

# スコアの更新
proc update_score {n d s o} {
    global name date score piece_num
    for {set i 9} {$i >= $o} {incr i -1} {
    set j [expr $i + 1]
    set name($piece_num,$j) $name($piece_num,$i)
    set date($piece_num,$j) $date($piece_num,$i)
    set score($piece_num,$j) $score($piece_num,$i)
    }
    set name($piece_num,$o) $n
    set date($piece_num,$o) $d
    set score($piece_num,$o) $s
}

# トップテンの名前入力
proc input_hi_score_name {ranking} {
    global buff2
    set buff2 ""
    toplevel .t2
    wm title .t2 "Input Your Name"
    wm geometry .t2 "+[expr [winfo x .] + 120]+[expr [winfo y .] + 180]"
    label .t2.l0 -text [format "おめでとう！ %d 位です" $ranking]
    label .t2.l1 -text "名前を入力してね"
    entry .t2.e0 -textvariable buff2
    focus -force .t2.e0
    grab set -global .t2
    bind .t2.e0 <Return> {
    # 入力チェックが必要か
    if {$buff2 != ""} {
        destroy .t2
    }
    }
    pack .t2.l0 .t2.l1 .t2.e0
}

# 初期化
proc init_board {} {
    global board piece board_l piece_l
    for {set x 0} {$x < 6} {incr x} {
    for {set y 0} {$y < 8} {incr y} {
        set board($x,$y) 0
        .c0 itemconfigure $piece($x,$y) -fill gray60
    }
    }
    for {set x 0} {$x < 6} {incr x} {
    set board_l($x) 0
    .c0 itemconfigure $piece_l($x) -fill gray60
    }
}

# 駒を消せるか
proc check_remove_yoko {x y} {
    global board remove_piece
    set c $board($x,$y)
    set i 1
    set xs $x
    # 左
    for {set x1 [expr $x - 1]} {$x1 >= 0} {incr x1 -1} {
    if {$board($x1,$y) != $c} break
    set xs $x1
    incr i
    }
    # 右
    set xe $x
    for {set x1 [expr $x + 1]} {$x1 < 6} {incr x1} {
    if {$board($x1,$y) != $c} break
    set xe $x1
    incr i
    }
    if {$i >= 3} {
    # 消去できる
    while {$xs <= $xe} {
        set remove_piece [concat $remove_piece $xs $y]
        incr xs
    }
    }
}

proc check_remove_tate {x y} {
    global board remove_piece
    set c $board($x,$y)
    set i 1
    set ys $y
    # 上
    for {set y1 [expr $y - 1]} {$y1 >= 0} {incr y1 -1} {
    if {$board($x,$y1) != $c} break
    set ys $y1
    incr i
    }
    # 下
    set ye $y
    for {set y1 [expr $y + 1]} {$y1 < 8} {incr y1} {
    if {$board($x,$y1) != $c} break
    set ye $y1
    incr i
    }
    if {$i >= 3} {
    # 消去できる
    while {$ys <= $ye} {
        set remove_piece [concat $remove_piece $x $ys]
        incr ys
    }
    }
}

# 左上 <-- (x,y) --> 右下
proc check_remove_naname1 {x y} {
    global board remove_piece
    set c $board($x,$y)
    set i 1
    # 左上
    set xs $x
    set ys $y
    set x1 [expr $x - 1]
    set y1 [expr $y - 1]
    while {$x1 >= 0 && $y1 >= 0} {
    if {$board($x1,$y1) != $c} break
    set xs $x1
    set ys $y1
    incr x1 -1
    incr y1 -1
    incr i
    }
    # 右下
    set xe $x
    set ye $y
    set x1 [expr $x + 1]
    set y1 [expr $y + 1]
    while {$x1 < 6 && $y1 < 8} {
    if {$board($x1,$y1) != $c} break
    set xe $x1
    set ye $y1
    incr x1
    incr y1
    incr i
    }
    if {$i >= 3} {
    # 消去できる
    while {$xs <= $xe} {
        set remove_piece [concat $remove_piece $xs $ys]
        incr xs
        incr ys
    }
    }
}

# 左下 <-- (x,y) --> 右上
proc check_remove_naname2 {x y} {
    global board remove_piece
    set c $board($x,$y)
    set i 1
    # 左下
    set xs $x
    set ys $y
    set x1 [expr $x - 1]
    set y1 [expr $y + 1]
    while {$x1 >= 0 && $y1 < 8} {
    if {$board($x1,$y1) != $c} break
    set xs $x1
    set ys $y1
    incr x1 -1
    incr y1
    incr i
    }
    # 右上
    set xe $x
    set ye $y
    set x1 [expr $x + 1]
    set y1 [expr $y - 1]
    while {$x1 < 6 && $y1 >= 0} {
    if {$board($x1,$y1) != $c} break
    set xe $x1
    set ye $y1
    incr x1
    incr y1 -1
    incr i
    }
    if {$i >= 3} {
    # 消去できる
    while {$xs <= $xe} {
        set remove_piece [concat $remove_piece $xs $ys]
        incr xs
        incr ys -1
    }
    }
}

# スコアの表示
proc display_score {num count} {
    global message1 now_score
    # 1 -> 2 -> 4 -> 8 と連鎖するたびに得点が増える
    set c [expr 1 << $count]
    incr now_score [expr $c * $c * $num * $num]
    set message1 [format "            Score %6d" $now_score]
}

# 駒を消去する
proc delete_piece {count} {
    global board remove_piece piece now_score
    set len [llength $remove_piece]
    set i 0
    set j 0
    while {$i < $len} {
    set x [lindex $remove_piece $i]
    incr i
    set y [lindex $remove_piece $i]
    incr i
    if {$board($x,$y) != 0} {
        set board($x,$y) 0
        incr j
        # タグを付ける
        .c0 itemconfigure $piece($x,$y) -tags remove
    }
    }
    # アニメーションさせる
    foreach c {white gray90 gray75 gray60} {
    .c0 itemconfigure remove -fill $c
    update
    after 150
    }
    # タグを取り除く
    .c0 dtag remove remove
    # スコアの計算
    display_score $j $count
}

# 駒の交換 (x1,y1) <--- (x2,y2)
proc change_piece {x1 y1 x2 y2} {
    global board piece color down_piece
    set c $board($x2,$y2)
    set board($x1,$y1) $c
    set board($x2,$y2) 0
    .c0 itemconfigure $piece($x1,$y1) -fill $color($c)
    .c0 itemconfigure $piece($x2,$y2) -fill gray60
    set down_piece [concat $down_piece $x1 $y1]
}

# 空いている位置に駒を移動させる
proc move_piece_down {} {
    global block board down_piece
    set down_piece ""
    for {set x 0} {$x < 6} {incr x 1} {
    # 空いている位置を探す
    set ys 7
    while {$ys >= 0} {
        if {$board($x,$ys) == 0} break
        incr ys -1
    }
    while {$ys > 0} {
        # 駒を探す
        set ye [expr $ys - 1]
        while {$ye >= 0} {
        if {$board($x,$ye) != 0} break
        incr ye -1
        }
        # 駒が見つからなければループから脱出
        if {$ye < 0} break
        # 移動
        change_piece $x $ys $x $ye
        incr ys -1
    }
    }
}

# 駒を消すことができるか
proc check_remove_piece {} {
    global board block_x remove_piece down_piece
    set remove_piece ""
    # 押し上げた列をチェック
    for {set x 0} {$x < 2} {incr x} {
    set x1 [expr $block_x + $x]
        for {set y 7} {$y >= 0} {incr y -1} {
        if {$board($x1,$y) == 0} break
        check_remove_yoko    $x1 $y
        check_remove_tate    $x1 $y
        check_remove_naname1 $x1 $y
        check_remove_naname2 $x1 $y
    }
    }
    set count 0
    while {$remove_piece != ""} {
    update
    after 250
    # 消去できる
    delete_piece $count
    # ブロックを落とす
    move_piece_down
    # 落としたブロックのチェック
    set remove_piece ""
    set len [llength $down_piece]
    set i 0
    while {$i < $len} {
        set x [lindex $down_piece $i]
        incr i
        set y [lindex $down_piece $i]
        incr i
        check_remove_yoko    $x $y
        check_remove_tate    $x $y
        check_remove_naname1 $x $y
        check_remove_naname2 $x $y
    }
    incr count
    }
}

# ブロックの移動
proc move_block_up {} {
    global block block_x play_flag board piece color
    if {$play_flag != 1} return
    set x1 $block_x
    set x2 [expr $x1 + 1]
    # 上に空きがあるか
    if {$board($x1,0) != 0 || $board($x2,0) != 0} return
    # 二重入力禁止
    set play_flag 2
    # ブロックを挿入する
    for {set y 1} {$y <= 7} {incr y} {
    set y1 [expr $y - 1]
    set board($x1,$y1) $board($x1,$y)
    set board($x2,$y1) $board($x2,$y)
    .c0 itemconfigure $piece($x1,$y1) -fill $color($board($x1,$y1))
    .c0 itemconfigure $piece($x2,$y1) -fill $color($board($x2,$y1))
    }
    set board($x1,7) $block(0)
    set board($x2,7) $block(1)
    .c0 itemconfigure $piece($x1,7) -fill $color($board($x1,7))
    .c0 itemconfigure $piece($x2,7) -fill $color($board($x2,7))
    # ブロックを消去
    delete_block
    check_remove_piece
    if [check_game_over] {
    game_over
    } else {
    set_block_start
    decide_next_block
    # 入力禁止解除
    set play_flag 1
    }
}

proc move_block_right {} {
    global block block_x play_flag
    if {$play_flag != 1} return
    # 右端のチェック
    if {$block_x == 4} return
    delete_block
    # 移動
    incr block_x
    display_block
    update
}

proc move_block_left {} {
    global block_x play_flag
    if {$play_flag != 1} return
    # 左端のチェック
    if {$block_x == 0} return
    delete_block
    # 移動
    incr block_x -1
    display_block
    update
}

# ブロックの回転
proc rotation_block {} {
    global block play_flag
    if {$play_flag != 1} return
    set temp $block(0)
    set block(0) $block(1)
    set block(1) $temp
    display_block
    update
}

# ブロックを消去する
proc delete_block {} {
    global block piece_l block_x
    set x $block_x
    for {set i 0} {$i < 2} {incr i} {
    .c0 itemconfigure $piece_l($x) -fill gray60
    incr x
    }
}

# ブロックを表示する
proc display_block {} {
    global block block_x block_l piece_l color
    set x $block_x
    for {set i 0} {$i < 2} {incr i} {
    .c0 itemconfigure $piece_l($x) -fill $color($block($i))
    incr x
    }
}

# 次のブロックを決める
proc decide_next_block {} {
    global next_block next_piece color piece_num
    for {set i 0} {$i < 2} {incr i} {
    set c [expr int( rand() * $piece_num ) + 1]
    set next_block($i) $c
    .c0 itemconfigure $next_piece($i) -fill $color($c)
    }
}

# ブロックを開始位置にセット
proc set_block_start {} {
    global next_block block block_x
    set block_x 4
    for {set i 0} {$i < 2} {incr i} {
    set block($i) $next_block($i)
    }
    display_block
}

# 手詰まりをチェック
proc check_game_over {} {
    global board
    for {set x1 0} {$x1 < 5} {incr x1} {
    set x2 [expr $x1 + 1]
    if {$board($x1,0) == 0 && $board($x2,0) == 0} {
        return 0
    }
    }
    return 1
}

# ゲーム終了
proc game_over {} {
    global now_score buff2 play_flag
    set ranking [check_hi_score $now_score]
    if {$ranking > 0} {
    input_hi_score_name $ranking
    tkwait window .t2
    update_score $buff2 [clock seconds] $now_score $ranking
    write_score_file
    open_score_window $ranking
    } else {
    tk_messageBox -type ok -message "得点は $now_score 点でした"
    }
    set play_flag 0
}


# ゲームの開始
proc start_game {} {
    global now_score move_count play_flag
    global piece_num color_num
    if {$play_flag != 0} {
    set ans [tk_messageBox -type yesno -icon question \
                   -message "ゲームを中断しますか？"]
        if {$ans == "no"} return
    set play_flag 0
    }
    set now_score 0
    set move_count 0
    set play_flag 1
    set piece_num $color_num
    init_board
    decide_next_block
    set_block_start
    decide_next_block
    display_block
    display_score 0 0
    update
}

# バインド  カーソルキーにも対応
bind . 5       "rotation_block"
bind . <Down>  "rotation_block"
bind . <Up>    "move_block_up"
bind . <space> "move_block_up"
bind . 8       "move_block_up"
bind . 4       "move_block_left"
bind . <Left>  "move_block_left"
bind . 6       "move_block_right"
bind . <Right> "move_block_right"

bind . s "start_game"


# ********** メニューの設定 **********
menu .m -type menubar
. configure -menu .m
.m add cascade -label "Games"    -under 0 -menu .m.m1
.m add cascade -label "Color"    -under 0 -menu .m.m2
.m add command -label "Help"     -under 0 -command "help"
menu .m.m1 -tearoff no
.m.m1 add command -label "Start"   -under 0 -command "start_game"
.m.m1 add command -label "HiScore" -under 0 -command "open_score_window 0"
.m.m1 add separator
.m.m1 add command -label "Exit" -under 0 -command "exit"
menu .m.m2 -tearoff no
.m.m2 add radiobutton -label "6 Colors" -variable color_num -value 6
.m.m2 add radiobutton -label "7 Colors" -variable color_num -value 7
.m.m2 add radiobutton -label "8 Colors" -variable color_num -value 8

# ********** 画面の生成 **********
option add *font "{ＭＳ ゴシック} 12"
canvas .c0 -width 320 -height 320
.c0 create rectangle 0 0 320 320 -fill darkgreen

# board 用
for {set x 0} {$x < 6} {incr x} {
    set x1 [expr 32 * $x + 32]
    set x2 [expr $x1 + 32]
    for {set y 0} {$y < 8} {incr y} {
    set y1 [expr 32 * $y]
    set y2 [expr $y1 + 32]
    set piece($x,$y) [.c0 create rectangle $x1 $y1 $x2 $y2 -fill gray60 -outline gray60]
    }
}

# board_l 用
for {set x 0} {$x < 6} {incr x} {
    set x1 [expr 32 * $x + 32]
    set x2 [expr $x1 + 32]
    set piece_l($x) [.c0 create rectangle $x1 264 $x2 296 -fill gray60 -outline gray60]
}


# next block 用
for {set x 0} {$x < 2} {incr x} {
    set x1 [expr 32 * $x + 232]
    set x2 [expr $x1 + 32]
    set next_piece($x) [.c0 create rectangle $x1 264 $x2 296 -fill gray60 -outline gray60]
}
.c0 create text 264 250 -text "ＮＥＸＴ" -fill white


# 色の設定
set x 0
foreach c {gray60 red blue yellow green cyan purple orange seagreen} {
    set color($x) $c
    incr x
}

# スコア表示用
label .l0 -textvariable message1 -bg darkgreen -fg white -anchor w

pack .l0 -fill x
pack .c0

# 窓の題名
wm title . "Block Up"
wm resizable . 0 0

# 初期化
set play_flag 0
set color_num 6
set path_name [file dirname $argv0]
set score_file "$path_name/BLOCKUP.SCO"

# スコアファイルのリード
read_score_file
focus -force .

# end of file